# pol models (across performance and neutral)
m1.pol <- readRDS(file = here(pol_model_dir, "m1.pol.rds"))
m2.pol <- readRDS(file = here(pol_model_dir, "m2.pol.rds"))
m3.pol <- readRDS(file = here(pol_model_dir, "m3.pol.rds"))
m4.pol <- readRDS(file = here(pol_model_dir, "m4.pol.rds"))
m5.pol <- readRDS(file = here(pol_model_dir, "m5.pol.rds"))
m6.pol <- readRDS(file = here(pol_model_dir, "m6.pol.rds"))
# performance models
m1.per <- readRDS(file = here(nonpol_model_dir, "m1.per.rds"))
m2.per <- readRDS(file = here(nonpol_model_dir, "m2.per.rds"))
m3.per <- readRDS(file = here(nonpol_model_dir, "m3.per.rds"))
m4.per <- readRDS(file = here(nonpol_model_dir, "m4.per.rds"))
m5.per <- readRDS(file = here(nonpol_model_dir, "m5.per.rds"))
m6.per <- readRDS(file = here(nonpol_model_dir, "m6.per.rds"))
# neutral models
m1.neu <- readRDS(file = here(nonpol_model_dir, "m1.neu.rds"))
m2.neu <- readRDS(file = here(nonpol_model_dir, "m2.neu.rds"))
m3.neu <- readRDS(file = here(nonpol_model_dir, "m3.neu.rds"))
m4.neu <- readRDS(file = here(nonpol_model_dir, "m4.neu.rds"))
m5.neu <- readRDS(file = here(nonpol_model_dir, "m5.neu.rds"))
m6.neu <- readRDS(file = here(nonpol_model_dir, "m6.neu.rds"))Figures and tables based on ideo motive analyses (secondary)
Preparations
Load models
Load original data
data_path <- here("01_data", "analysis", "data_analysis.RData")
load(file = data_path)Filters
initial_rows <- nrow(data_analysis)
data_prep <- data_analysis %>%
filter(Screen != "Question")
filtered_rows <- initial_rows - nrow(data_prep)
filtered_rows[1] 5389
data_full <- data_prep %>%
filter(question_type %in% c("political", "performance", "nonpolitical")) %>%
mutate(question_topic = factor(question_topic,
levels = c("climate",
"gender",
"immigration",
"discrimination",
"adoption",
"punishment",
"gonogo_performance",
"fakenews_performance",
"teaculture",
"brain"))) %>%
droplevels()
unique(data_full$question_topic) [1] adoption climate punishment gender
[5] discrimination gonogo_performance immigration teaculture
[9] fakenews_performance brain
10 Levels: climate gender immigration discrimination adoption ... brain
Data types
data_full <- data_full %>%
mutate(ideo_motive_strength = factor(ideo_motive_strength,
levels = c("Anti-strong",
"Anti-moderate",
"Anti-weak",
"Neutral",
"Pro-weak",
"Pro-moderate",
"Pro-strong"),
ordered = TRUE)) Data for submodels
data_pol <- data_full %>%
filter(question_type == "political") %>%
droplevels()
data_per <- data_full %>%
filter(question_type == "performance") %>%
droplevels()
data_neu <- data_full %>%
filter(question_type == "nonpolitical") %>%
droplevels()
unique(data_pol$question_topic)[1] adoption climate punishment gender discrimination
[6] immigration
Levels: climate gender immigration discrimination adoption punishment
unique(data_per$question_topic)[1] gonogo_performance fakenews_performance
Levels: gonogo_performance fakenews_performance
unique(data_neu$question_topic)[1] teaculture brain
Levels: teaculture brain
Table 1: Parameter estimates of interest m1, m3, m4 (logit)
Create a logit table with main parameters of interest of m1, m3, m4.
m1 table
h0a.pol <- hypothesis(m1.pol, "ideo_motivePro > 0",
alpha = 0.025,
seed = 42)
h0a.per <- hypothesis(m1.per, "ideo_motivePro > 0",
alpha = 0.025,
seed = 42)
h0a.neu <- hypothesis(m1.neu, "ideo_motivePro > 0",
alpha = 0.025,
seed = 42)
h0a.pol$hypothesis$Evid.Ratio[1] 54.2
h0a.per$hypothesis$Evid.Ratio[1] 7999
h0a.neu$hypothesis$Evid.Ratio[1] 1.05
h0b.pol <- hypothesis(m1.pol, "ideo_motivePro < 0",
alpha = 0.025,
seed = 42)
h0b.per <- hypothesis(m1.per, "ideo_motivePro < 0",
alpha = 0.025,
seed = 42)
h0b.neu <- hypothesis(m1.neu, "ideo_motivePro < 0",
alpha = 0.025,
seed = 42)
h0b.pol$hypothesis$Evid.Ratio[1] 0.0185
h0b.per$hypothesis$Evid.Ratio[1] 0.000125
h0b.neu$hypothesis$Evid.Ratio[1] 0.95
m1.pol.logit <- describe_posterior(m1.pol, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Political") %>%
mutate("β > 0" = h0a.pol$hypothesis$Evid.Ratio,
"β < 0" = h0b.pol$hypothesis$Evid.Ratio)
m1.per.logit <- describe_posterior(m1.per, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Performance") %>%
mutate("β > 0" = h0a.per$hypothesis$Evid.Ratio,
"β < 0" = h0b.per$hypothesis$Evid.Ratio)
m1.neu.logit <- describe_posterior(m1.neu, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Neutral") %>%
mutate("β > 0" = h0a.neu$hypothesis$Evid.Ratio,
"β < 0" = h0b.neu$hypothesis$Evid.Ratio)
m1.logit <- bind_rows(m1.pol.logit, m1.per.logit, m1.neu.logit) %>%
select("Question Type", Parameter, Median,
CI_low, CI_high, "β > 0", "β < 0") %>%
rename("LL" = CI_low,
"UL" = CI_high) %>%
filter(Parameter == "b_ideo_motivePro") %>%
mutate(Parameter = "Motive (Pro > Anti)") %>%
mutate(across(where(is.numeric), ~ round(.x, 3)))
m1.logitSummary of Posterior Distribution
Question Type | Parameter | Median | LL | UL | β > 0 | β < 0
-------------------------------------------------------------------------------
Political | Motive (Pro > Anti) | 0.22 | 0.03 | 0.41 | 54.17 | 0.02
Performance | Motive (Pro > Anti) | 0.22 | 0.10 | 0.34 | 7999.00 | 0.00
Neutral | Motive (Pro > Anti) | 2.00e-03 | -0.14 | 0.14 | 1.05 | 0.95
m3 table
h1a.pol <- hypothesis(m3.pol, "ideo_motivePro:scalecrt_correct > 0",
alpha = 0.025,
seed = 42)
h1a.per <- hypothesis(m3.per, "ideo_motivePro:scalecrt_correct > 0",
alpha = 0.025,
seed = 42)
h1a.neu <- hypothesis(m3.neu, "ideo_motivePro:scalecrt_correct > 0",
alpha = 0.025,
seed = 42)
h1a.pol$hypothesis$Evid.Ratio[1] 0.94
h1a.per$hypothesis$Evid.Ratio[1] 19.6
h1a.neu$hypothesis$Evid.Ratio[1] 0.955
h1b.pol <- hypothesis(m3.pol, "ideo_motivePro:scalecrt_correct < 0",
alpha = 0.025,
seed = 42)
h1b.per <- hypothesis(m3.per, "ideo_motivePro:scalecrt_correct < 0",
alpha = 0.025,
seed = 42)
h1b.neu <- hypothesis(m3.neu, "ideo_motivePro:scalecrt_correct < 0",
alpha = 0.025,
seed = 42)
h1b.pol$hypothesis$Evid.Ratio[1] 1.06
h1b.per$hypothesis$Evid.Ratio[1] 0.0511
h1b.neu$hypothesis$Evid.Ratio[1] 1.05
m3.pol.logit <- describe_posterior(m3.pol, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Political") %>%
mutate("β > 0" = h1a.pol$hypothesis$Evid.Ratio,
"β < 0" = h1b.pol$hypothesis$Evid.Ratio)
m3.per.logit <- describe_posterior(m3.per, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Performance") %>%
mutate("β > 0" = h1a.per$hypothesis$Evid.Ratio,
"β < 0" = h1b.per$hypothesis$Evid.Ratio)
m3.neu.logit <- describe_posterior(m3.neu, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Neutral") %>%
mutate("β > 0" = h1a.neu$hypothesis$Evid.Ratio,
"β < 0" = h1b.neu$hypothesis$Evid.Ratio)
m3.logit <- bind_rows(m3.pol.logit, m3.per.logit, m3.neu.logit) %>%
select("Question Type", Parameter, Median,
CI_low, CI_high, "β > 0", "β < 0") %>%
rename("LL" = CI_low,
"UL" = CI_high) %>%
filter(Parameter == "b_ideo_motivePro:scalecrt_correct") %>%
mutate(Parameter = "Motive x Cognitive Reflection") %>%
mutate(across(where(is.numeric), ~ round(.x, 3)))
m3.logitSummary of Posterior Distribution
Question Type | Parameter | Median | LL | UL | β > 0 | β < 0
----------------------------------------------------------------------------------------
Political | Motive x Cognitive Reflection | -2.00e-03 | -0.07 | 0.07 | 0.94 | 1.06
Performance | Motive x Cognitive Reflection | 0.11 | -0.02 | 0.23 | 19.57 | 0.05
Neutral | Motive x Cognitive Reflection | -2.00e-03 | -0.14 | 0.14 | 0.95 | 1.05
m4 table
h2a.pol <- hypothesis(m4.pol, "ideo_motivePro:scalecommission_errors_r > 0",
alpha = 0.025,
seed = 42)
h2a.per <- hypothesis(m4.per, "ideo_motivePro:scalecommission_errors_r > 0",
alpha = 0.025,
seed = 42)
h2a.neu <- hypothesis(m4.neu, "ideo_motivePro:scalecommission_errors_r > 0",
alpha = 0.025,
seed = 42)
h2a.pol$hypothesis$Evid.Ratio[1] 1.17
h2a.per$hypothesis$Evid.Ratio[1] 72.4
h2a.neu$hypothesis$Evid.Ratio[1] 1.19
h2b.pol <- hypothesis(m4.pol, "ideo_motivePro:scalecommission_errors_r < 0",
alpha = 0.025,
seed = 42)
h2b.per <- hypothesis(m4.per, "ideo_motivePro:scalecommission_errors_r < 0",
alpha = 0.025,
seed = 42)
h2b.neu <- hypothesis(m4.neu, "ideo_motivePro:scalecommission_errors_r < 0",
alpha = 0.025,
seed = 42)
h2b.pol$hypothesis$Evid.Ratio[1] 0.855
h2b.per$hypothesis$Evid.Ratio[1] 0.0138
h2b.neu$hypothesis$Evid.Ratio[1] 0.839
m4.pol.logit <- describe_posterior(m4.pol, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Political") %>%
mutate("β > 0" = h2a.pol$hypothesis$Evid.Ratio,
"β < 0" = h2b.pol$hypothesis$Evid.Ratio)
m4.per.logit <- describe_posterior(m4.per, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Performance") %>%
mutate("β > 0" = h2a.per$hypothesis$Evid.Ratio,
"β < 0" = h2b.per$hypothesis$Evid.Ratio)
m4.neu.logit <- describe_posterior(m4.neu, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Neutral") %>%
mutate("β > 0" = h2a.neu$hypothesis$Evid.Ratio,
"β < 0" = h2b.neu$hypothesis$Evid.Ratio)
m4.logit <- bind_rows(m4.pol.logit, m4.per.logit, m4.neu.logit) %>%
select("Question Type", Parameter, Median,
CI_low, CI_high, "β > 0", "β < 0") %>%
rename("LL" = CI_low,
"UL" = CI_high) %>%
filter(Parameter == "b_ideo_motivePro:scalecommission_errors_r") %>%
mutate(Parameter = "Motive x Inhibitory Control") %>%
mutate(across(where(is.numeric), ~ round(.x, 3)))
m4.logitSummary of Posterior Distribution
Question Type | Parameter | Median | LL | UL | β > 0 | β < 0
-------------------------------------------------------------------------------------
Political | Motive x Inhibitory Control | 4.00e-03 | -0.07 | 0.08 | 1.17 | 0.85
Performance | Motive x Inhibitory Control | 0.14 | 0.01 | 0.26 | 72.39 | 0.01
Neutral | Motive x Inhibitory Control | 8.00e-03 | -0.13 | 0.14 | 1.19 | 0.84
Combined table
combined_logit <- bind_rows(m1.logit, m3.logit, m4.logit) %>%
mutate(`Question Type` = factor(`Question Type`, levels = c("Political", "Performance", "Neutral"))) %>%
arrange(`Question Type`, Parameter)
combined_logit_table <- combined_logit %>%
select(-c("Question Type")) %>%
tt() %>%
group_tt(
i = list(
"Political Vignettes" = 1,
"Performance Vignettes" = 4,
"Neutral Vignettes" = 7
),
j = list(
"95% CI" = 3:4,
"Evidence Ratio" = 5:6))
combined_logit_table %>% save_tt(here(table_dir, "combined_logit_table.docx"), overwrite = TRUE)
combined_logit_table| 95% CI | Evidence Ratio | ||||
|---|---|---|---|---|---|
| Parameter | Median | LL | UL | β > 0 | β < 0 |
| Motive (Pro > Anti) | 0.220 | 0.027 | 0.410 | 54.172 | 0.018 |
| Motive x Cognitive Reflection | -0.002 | -0.074 | 0.072 | 0.940 | 1.064 |
| Motive x Inhibitory Control | 0.004 | -0.069 | 0.076 | 1.169 | 0.855 |
| Motive (Pro > Anti) | 0.221 | 0.100 | 0.345 | 7999.000 | 0.000 |
| Motive x Cognitive Reflection | 0.108 | -0.019 | 0.230 | 19.566 | 0.051 |
| Motive x Inhibitory Control | 0.140 | 0.014 | 0.263 | 72.394 | 0.014 |
| Motive (Pro > Anti) | 0.002 | -0.136 | 0.140 | 1.053 | 0.950 |
| Motive x Cognitive Reflection | -0.002 | -0.136 | 0.138 | 0.955 | 1.048 |
| Motive x Inhibitory Control | 0.008 | -0.128 | 0.141 | 1.192 | 0.839 |
Main Text: Reported Percentage Predictions m1, m3
m1: Pro vs. Anti in %
Calculate % comparisons
m1.pol.com <- m1.pol %>%
avg_comparisons() %>%
as_tibble() %>%
select(contrast, estimate, conf.low, conf.high) %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(contrast = recode(contrast,
"mean(Pro) - mean(Anti)" = "Pro - Anti"),
"Question Type" = "Political") %>%
rename("Contrast" = "contrast",
"Estimate" = "estimate",
"LL" = "conf.low",
"UL" = "conf.high")m1.per.com <- m1.per %>%
avg_comparisons() %>%
as_tibble() %>%
select(contrast, estimate, conf.low, conf.high) %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(contrast = recode(contrast,
"mean(Pro) - mean(Anti)" = "Pro - Anti"),
"Question Type" = "Performance") %>%
rename("Contrast" = "contrast",
"Estimate" = "estimate",
"LL" = "conf.low",
"UL" = "conf.high")m1.neu.com <- m1.neu %>%
avg_comparisons() %>%
as_tibble() %>%
select(contrast, estimate, conf.low, conf.high) %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(contrast = recode(contrast,
"mean(Pro) - mean(Anti)" = "Pro - Anti"),
"Question Type" = "Neutral") %>%
rename("Contrast" = "contrast",
"Estimate" = "estimate",
"LL" = "conf.low",
"UL" = "conf.high")Combined table
m1.combined_perc <- bind_rows(m1.pol.com, m1.per.com, m1.neu.com) %>%
mutate(`Question Type` = factor(`Question Type`, levels = c("Political", "Performance", "Neutral")))
m1.combined_perc_table <- m1.combined_perc %>%
select(-c("Question Type")) %>%
tt() %>%
group_tt(
i = list(
"Political Vignettes" = 1,
"Performance Vignettes" = 2,
"Neutral Vignettes" = 3
),
j = list(
"95% CI" = 3:4))
m1.combined_perc_table %>% save_tt(here(table_dir, "m1_combined_perc_table.docx"), overwrite = TRUE)
m1.combined_perc_table| 95% CI | |||
|---|---|---|---|
| Contrast | Estimate | LL | UL |
| Pro - Anti | 0.05602 | 0.0383 | 0.0736 |
| Pro - Anti | 0.05612 | 0.0264 | 0.0859 |
| Pro - Anti | -0.00334 | -0.0370 | 0.0307 |
m3: Pro vs. Anti for CRT = 3 and CRT = 0 in %
crt.newdata <-
expand_grid(ideo_motive = c("Pro", "Anti"),
crt_correct = c(0, 3))m3.pol.com <- m3.pol %>%
epred_draws(newdata = crt.newdata,
re_formula = NA) %>%
group_by(crt_correct) %>%
compare_levels(.epred, by = ideo_motive) %>%
compare_levels(.epred, by = crt_correct) %>%
median_qi(.width = 0.95)m3.pol.com %>% tt()| crt_correct | ideo_motive | .epred | .lower | .upper | .width | .point | .interval |
|---|---|---|---|---|---|---|---|
| 3 - 0 | Pro - Anti | -0.00132 | -0.0492 | 0.0472 | 0.95 | median | qi |
Figure: Motivated Reasoning on Different Topics
Extract draws
Average effect of motivated reasoning on political, performance, and neutral topics
m1.pol.draws <- m1.pol %>%
avg_comparisons(variables = "ideo_motive") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(question_type = "Political",
question_topic = "average")
m1.pol.draws %>% median_hdi(draw)# A tibble: 1 × 6
draw .lower .upper .width .point .interval
<dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 0.0560 0.0379 0.0730 0.95 median hdi
m1.per.draws <- m1.per %>%
avg_comparisons(variables = "ideo_motive") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(question_type = "Performance",
question_topic = "average")
m1.per.draws %>% median_hdi(draw)# A tibble: 1 × 6
draw .lower .upper .width .point .interval
<dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 0.0561 0.0267 0.0860 0.95 median hdi
m1.neu.draws <- m1.neu %>%
avg_comparisons(variables = "ideo_motive") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(question_type = "Neutral",
question_topic = "average")
m1.neu.draws %>% median_hdi(draw)# A tibble: 1 × 6
draw .lower .upper .width .point .interval
<dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 -0.00334 -0.0370 0.0307 0.95 median hdi
Motivated reasoning by topic
m1.pol.topic <- avg_comparisons(m1.pol,
variables = "ideo_motive",
by = "question_topic") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(question_type = "Political")
m1.pol.topic %>% group_by(question_topic) %>% median_hdi(draw)# A tibble: 6 × 7
question_topic draw .lower .upper .width .point .interval
<fct> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 climate 0.0545 0.0179 0.0890 0.95 median hdi
2 gender 0.0244 -0.0139 0.0616 0.95 median hdi
3 immigration 0.0913 0.0533 0.126 0.95 median hdi
4 discrimination 0.0871 0.0477 0.127 0.95 median hdi
5 adoption 0.0597 0.0240 0.0943 0.95 median hdi
6 punishment 0.0205 -0.0187 0.0590 0.95 median hdi
m1.per.topic <- avg_comparisons(m1.per,
variables = "ideo_motive",
by = "question_topic") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(question_type = "Performance")
m1.per.topic %>% group_by(question_topic) %>% median_hdi(draw)# A tibble: 2 × 7
question_topic draw .lower .upper .width .point .interval
<fct> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 gonogo_performance 0.0665 0.0223 0.106 0.95 median hdi
2 fakenews_performance 0.0456 0.00326 0.0869 0.95 median hdi
m1.neu.topic <- avg_comparisons(m1.neu,
variables = "ideo_motive",
by = "question_topic") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(question_type = "Neutral")
m1.neu.topic %>% group_by(question_topic) %>% median_hdi(draw)# A tibble: 2 × 7
question_topic draw .lower .upper .width .point .interval
<fct> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 teaculture -0.0414 -0.0870 0.00307 0.95 median hdi
2 brain 0.0412 -0.00770 0.0915 0.95 median hdi
Create a combined dataframe
m1.combined <- bind_rows(m1.pol.draws, m1.pol.topic,
m1.per.draws, m1.per.topic,
m1.neu.draws, m1.neu.topic)m1.combined <- m1.combined %>%
mutate(question_topic = factor(question_topic,
levels = c("brain",
"teaculture",
"fakenews_performance",
"gonogo_performance",
"punishment",
"adoption",
"discrimination",
"gender",
"immigration",
"climate",
"average"),
labels = c("Brain proportion",
"Tea with milk",
"Fake News performance",
"Go / No-Go performance",
"Criminal reconviction",
"Same-sex adoption",
"Racial discrimination",
"Gender stereotypes",
"Immigrant population",
"Anthropogenic climate change",
"Average"
)),
draw_perc = draw*100) Create figure
average_color <- "#645CAA"
plot_political <- m1.combined %>%
filter(question_type == "Political") %>%
ggplot(aes(x = draw_perc, y = question_topic,
fill = question_topic == "Average")) +
stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95),
point_interval = "median_qi") +
geom_vline(xintercept = 0, alpha = 0.8, linewidth = 0.8,
color = "black", linetype = "dashed") +
scale_fill_manual(values = c(`TRUE` = average_color, `FALSE` = "#A685E2")) +
labs(subtitle = "Political Vignettes",
x = NULL, y = NULL) +
scale_x_continuous(labels = label_percent(scale = 1), limits = c(-10, 25),
breaks = seq(-10, 20, by = 5)) +
theme_ipsum_rc(base_size = 16,
subtitle_size = 18,
subtitle_face = "bold",
axis_text_size = 16,
grid = "XY") +
guides(fill = "none") +
theme(legend.position = "none")
plot_performance <- m1.combined %>%
filter(question_type == "Performance") %>%
ggplot(aes(x = draw_perc, y = question_topic,
fill = question_topic == "Average")) +
stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95),
point_interval = "median_qi") +
geom_vline(xintercept = 0, alpha = 0.8, linewidth = 0.8,
color = "black", linetype = "dashed") +
scale_fill_manual(values = c(`TRUE` = average_color, `FALSE` = "#FF8DC7")) +
labs(subtitle = "Performance Vignettes",
x = NULL, y = NULL) +
scale_x_continuous(labels = label_percent(scale = 1), limits = c(-10, 25)) +
theme_ipsum_rc(base_size = 16,
subtitle_size = 18,
subtitle_face = "bold",
axis_text_size = 16,
grid = "XY") +
guides(fill = "none") +
theme(legend.position = "none")
plot_neutral <- m1.combined %>%
filter(question_type == "Neutral") %>%
ggplot(aes(x = draw_perc, y = question_topic,
fill = question_topic == "Average")) +
stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95),
point_interval = "median_qi") +
geom_vline(xintercept = 0, alpha = 0.8, linewidth = 0.8,
color = "black", linetype = "dashed") +
scale_fill_manual(values = c(`TRUE` = average_color, `FALSE` = "#FFABE1")) +
labs(subtitle = "Neutral Vignettes",
x = NULL, y = NULL) +
scale_x_continuous(labels = label_percent(scale = 1), limits = c(-10, 25)) +
theme_ipsum_rc(base_size = 16,
subtitle_size = 18,
subtitle_face = "bold",
axis_text_size = 16,
grid = "XY") +
guides(fill = "none") +
theme(legend.position = "none")
main_effect_plot <- plot_political / (plot_performance | plot_neutral) +
plot_layout(heights = c(2, 1))
main_effect_plotWarning: Removed 38 rows containing missing values or values outside the scale range
(`stat_slabinterval()`).
ggsave(here(fig_dir, "m1_main_fig.png"), width = 12, height = 10, dpi = 300)Warning: Removed 38 rows containing missing values or values outside the scale range
(`stat_slabinterval()`).
Figure: The link to cognitive control variables
Extract political draws
m3.pol.draws <- avg_comparisons(m3.pol,
variables = "ideo_motive",
by = "crt_correct") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)")
m3.pol.draws %>% group_by(crt_correct) %>% median_hdi(draw)# A tibble: 4 × 7
crt_correct draw .lower .upper .width .point .interval
<dbl> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 2.22e-16 0.0575 0.0256 0.0868 0.95 median hdi
2 1 e+ 0 0.0558 0.0335 0.0797 0.95 median hdi
3 2 e+ 0 0.0551 0.0331 0.0750 0.95 median hdi
4 3 e+ 0 0.0567 0.0303 0.0833 0.95 median hdi
m4.pol.draws <- avg_comparisons(m4.pol,
variables = "ideo_motive",
by = "commission_errors_r",
newdata = expand_grid(ideo_motive = c("Pro", "Anti"),
commission_errors_r = seq(13, 56)),
re_formula = NA) %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)") Warning: The `ideo_motive` variable is treated as a categorical (factor) variable, but the
original data is of class character. It is safer and faster to convert such
variables to factor before fitting the model and calling a `marginaleffects`
function.
This warning appears once per session.
m4.pol.draws %>% group_by(commission_errors_r) %>% median_hdi(draw)# A tibble: 44 × 7
commission_errors_r draw .lower .upper .width .point .interval
<int> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 13 0.0546 -0.0148 0.129 0.95 median hdi
2 14 0.0547 -0.0150 0.125 0.95 median hdi
3 15 0.0549 -0.0125 0.124 0.95 median hdi
4 16 0.0551 -0.0111 0.123 0.95 median hdi
5 17 0.0551 -0.0114 0.120 0.95 median hdi
6 18 0.0553 -0.0104 0.117 0.95 median hdi
7 19 0.0555 -0.00811 0.117 0.95 median hdi
8 20 0.0556 -0.00743 0.115 0.95 median hdi
9 21 0.0555 -0.00392 0.115 0.95 median hdi
10 22 0.0557 -0.00139 0.114 0.95 median hdi
# ℹ 34 more rows
Create political figures
pol_crt_plot <- m3.pol.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = crt_correct, y = draw_perc, fill = factor(crt_correct))) +
stat_slabinterval(aes(ymin = conf.low * 100, ymax = conf.high * 100),
.width = c(0.5, 0.95),
alpha = 0.7,
position = position_dodge(width = 0.5)) +
scale_fill_manual(values = c("#E1AFD1", "#AD88C6", "#7469B6", "#6A2C70")) +
labs(title = "Cognitive Reflection and Motivated Reasoning",
subtitle = glue("Political vignettes (Evid.Ratio H1a > H1b = {round(h1a.pol$hypothesis$Evid.Ratio, 2)})"),
x = "Cognitive Reflection",
y = "Motivated Reasoning") +
scale_x_continuous(breaks = c(0, 1, 2, 3)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
plot_title_face = "bold",
axis_title_size = 14,
axis_text_size = 14,
grid = "XY") +
theme(legend.position = "none")
pol_crt_plotalt_pol_crt_plot <- m3.pol.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = crt_correct, y = draw_perc)) +
stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) +
scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
labs(title = "Cognitive Reflection and Motivated Reasoning",
subtitle = glue("Political vignettes (Evid.Ratio H2a > H2b = {round(h1a.pol$hypothesis$Evid.Ratio, 2)})"),
x = "Cognitive Reflection",
y = "Motivated Reasoning",
fill = "Credible interval") +
scale_x_continuous(breaks = c(0, 1, 2, 3)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
plot_title_face = "bold",
axis_title_size = 14,
axis_text_size = 14,
grid = "XY"
) +
theme(legend.position = "top")
alt_pol_crt_plotpol_gng_plot <- m4.pol.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = commission_errors_r, y = draw_perc)) +
stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) +
scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
labs(title = "Inhibitory Control and Motivated Reasoning",
subtitle = glue("Political vignettes (Evid.Ratio H2a > H2b = {round(h2a.pol$hypothesis$Evid.Ratio, 2)})"),
x = "Inhibitory Control",
y = "Motivated Reasoning",
fill = "Credible interval") +
scale_x_continuous(breaks = seq(15, 55, by = 10)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
plot_title_face = "bold",
axis_title_size = 14,
axis_text_size = 14,
grid = "XY"
) +
theme(legend.position = "top")
pol_gng_plotExtract performance and neutral draws
m3.per.draws <- avg_comparisons(m3.per,
variables = "ideo_motive",
by = "crt_correct") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)")
m3.per.draws %>% group_by(crt_correct) %>% median_hdi(draw)# A tibble: 4 × 7
crt_correct draw .lower .upper .width .point .interval
<dbl> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 2.22e-16 0.0190 -0.0315 0.0713 0.95 median hdi
2 1 e+ 0 0.0431 0.00785 0.0829 0.95 median hdi
3 2 e+ 0 0.0658 0.0295 0.101 0.95 median hdi
4 3 e+ 0 0.0880 0.0414 0.136 0.95 median hdi
m3.neu.draws <- avg_comparisons(m3.neu,
variables = "ideo_motive",
by = "crt_correct") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)")
m3.neu.draws %>% group_by(crt_correct) %>% median_hdi(draw)# A tibble: 4 × 7
crt_correct draw .lower .upper .width .point .interval
<dbl> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 0 -0.00161 -0.0573 0.0608 0.95 median hdi
2 1 -0.00127 -0.0431 0.0395 0.95 median hdi
3 2 -0.00719 -0.0466 0.0284 0.95 median hdi
4 3 -0.00334 -0.0512 0.0509 0.95 median hdi
m4.per.draws <- avg_comparisons(m4.per,
variables = "ideo_motive",
by = "commission_errors_r",
newdata = expand_grid(ideo_motive = c("Pro", "Anti"),
commission_errors_r = seq(13, 56),
question_topic = levels(data_per$question_topic)),
re_formula = NA) %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)")
m4.per.draws %>% group_by(commission_errors_r) %>% median_hdi(draw)# A tibble: 44 × 7
commission_errors_r draw .lower .upper .width .point .interval
<int> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 13 -0.0486 -0.145 0.0516 0.95 median hdi
2 14 -0.0442 -0.136 0.0530 0.95 median hdi
3 15 -0.0399 -0.130 0.0531 0.95 median hdi
4 16 -0.0357 -0.122 0.0532 0.95 median hdi
5 17 -0.0315 -0.114 0.0551 0.95 median hdi
6 18 -0.0271 -0.106 0.0554 0.95 median hdi
7 19 -0.0228 -0.0996 0.0556 0.95 median hdi
8 20 -0.0184 -0.0939 0.0540 0.95 median hdi
9 21 -0.0140 -0.0853 0.0556 0.95 median hdi
10 22 -0.00963 -0.0773 0.0573 0.95 median hdi
# ℹ 34 more rows
m4.neu.draws <- avg_comparisons(m4.neu,
variables = "ideo_motive",
by = "commission_errors_r",
newdata = expand_grid(ideo_motive = c("Pro", "Anti"),
commission_errors_r = seq(13, 56),
question_topic = levels(data_neu$question_topic)),
re_formula = NA) %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)")
m4.neu.draws %>% group_by(commission_errors_r) %>% median_hdi(draw)# A tibble: 44 × 7
commission_errors_r draw .lower .upper .width .point .interval
<int> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 13 -0.00479 -0.106 0.106 0.95 median hdi
2 14 -0.00456 -0.113 0.0921 0.95 median hdi
3 15 -0.00419 -0.0988 0.0987 0.95 median hdi
4 16 -0.00424 -0.0948 0.0953 0.95 median hdi
5 17 -0.00413 -0.0919 0.0906 0.95 median hdi
6 18 -0.00382 -0.0872 0.0876 0.95 median hdi
7 19 -0.00355 -0.0836 0.0842 0.95 median hdi
8 20 -0.00321 -0.0793 0.0809 0.95 median hdi
9 21 -0.00311 -0.0760 0.0774 0.95 median hdi
10 22 -0.00265 -0.0723 0.0739 0.95 median hdi
# ℹ 34 more rows
Create performance and neutral figures
per_crt_plot <- m3.per.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = crt_correct, y = draw_perc, fill = factor(crt_correct))) +
stat_slabinterval(aes(ymin = conf.low * 100, ymax = conf.high * 100),
.width = c(0.5, 0.95),
alpha = 0.7,
position = position_dodge(width = 0.5)) +
scale_fill_manual(values = c("#E1AFD1", "#AD88C6", "#7469B6", "#6A2C70")) +
labs(subtitle = glue("Performance vignettes
(Evid.Ratio H1a > H1b = {round(h1a.per$hypothesis$Evid.Ratio, 2)})"),
x = NULL,
y = NULL) +
scale_x_continuous(breaks = c(0, 1, 2, 3)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
axis_title_size = 14,
axis_text_size = 14,
grid = "XY") +
theme(legend.position = "none")
per_crt_plotalt_per_crt_plot <- m3.per.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = crt_correct, y = draw_perc)) +
stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) +
scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
labs(subtitle = glue("Performance vignettes
(Evid.Ratio H1a > H1b = {round(h1a.per$hypothesis$Evid.Ratio, 2)})"),
x = NULL,
y = NULL) +
scale_x_continuous(breaks = c(0, 1, 2, 3)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
axis_title_size = 14,
axis_text_size = 14,
grid = "XY") +
theme(legend.position = "none")
alt_per_crt_plotneu_crt_plot <- m3.neu.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = crt_correct, y = draw_perc, fill = factor(crt_correct))) +
stat_slabinterval(aes(ymin = conf.low * 100, ymax = conf.high * 100),
.width = c(0.5, 0.95),
alpha = 0.7,
position = position_dodge(width = 0.5)) +
scale_fill_manual(values = c("#E1AFD1", "#AD88C6", "#7469B6", "#6A2C70")) +
labs(subtitle = glue("Neutral vignettes
(Evid.Ratio H1a > H1b = {round(h1a.neu$hypothesis$Evid.Ratio, 2)})"),
x = NULL,
y = NULL) +
scale_x_continuous(breaks = c(0, 1, 2, 3)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
axis_title_size = 14,
axis_text_size = 14,
grid = "XY") +
theme(legend.position = "none")
neu_crt_plotper_gng_plot <- m4.per.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = commission_errors_r, y = draw_perc)) +
stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) +
scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
labs(subtitle = glue("Performance vignettes
(Evid.Ratio H2a > H2b = {round(h2a.per$hypothesis$Evid.Ratio, 2)})"),
x = NULL,
y = NULL) +
scale_x_continuous(breaks = seq(15, 55, by = 10)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
axis_title_size = 14,
axis_text_size = 14,
grid = "XY"
) +
theme(legend.position = "none")
per_gng_plotneu_gng_plot <- m4.neu.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = commission_errors_r, y = draw_perc)) +
stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) +
scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
labs(subtitle = glue("Neutral vignettes
(Evid.Ratio H2a > H2b = {round(h2a.neu$hypothesis$Evid.Ratio, 2)})"),
x = NULL,
y = NULL) +
scale_x_continuous(breaks = seq(15, 55, by = 10)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
axis_title_size = 14,
axis_text_size = 14,
grid = "XY"
) +
theme(legend.position = "none")
neu_gng_plotCombined plot
top_panel <- pol_crt_plot + pol_gng_plot +
plot_layout(ncol = 2, widths = c(1, 1))
bottom_left <- per_crt_plot + neu_crt_plot +
plot_layout(heights = c(1, 1), widths = c(0.5, 0.5))
bottom_right <- per_gng_plot + neu_gng_plot +
plot_layout(heights = c(1, 1), widths = c(1.5, 1.5))
cognitive_plot <- (top_panel / (bottom_left | bottom_right)) +
plot_layout(heights = c(1.5, 2))
cognitive_plotggsave(here(fig_dir, "cognitive_fig.png"), width = 12, height = 10, dpi = 300)Supplementary Table 3
Create a logit table with main parameters of interest of m2, m5, m6.
m2 table
h0a_mo.pol <- as_tibble(m2.pol) %>%
hypothesis(., "bsp_moideo_motive_strength > 0",
alpha = 0.025,
seed = 42)
h0a_mo.per <- as_tibble(m2.per) %>%
hypothesis(., "bsp_moideo_motive_strength > 0",
alpha = 0.025,
seed = 42)
h0a_mo.neu <- as_tibble(m2.neu) %>%
hypothesis(., "bsp_moideo_motive_strength > 0",
alpha = 0.025,
seed = 42)
h0a_mo.pol$hypothesis$Evid.Ratio[1] 92
h0a_mo.per$hypothesis$Evid.Ratio[1] 614
h0a_mo.neu$hypothesis$Evid.Ratio[1] 0.541
h0b_mo.pol <- as_tibble(m2.pol) %>%
hypothesis(., "bsp_moideo_motive_strength < 0",
alpha = 0.025,
seed = 42)
h0b_mo.per <- as_tibble(m2.per) %>%
hypothesis(., "bsp_moideo_motive_strength < 0",
alpha = 0.025,
seed = 42)
h0b_mo.neu <- as_tibble(m2.neu) %>%
hypothesis(., "bsp_moideo_motive_strength < 0",
alpha = 0.025,
seed = 42)
h0b_mo.pol$hypothesis$Evid.Ratio[1] 0.0109
h0b_mo.per$hypothesis$Evid.Ratio[1] 0.00163
h0b_mo.neu$hypothesis$Evid.Ratio[1] 1.85
m2.pol.logit <- describe_posterior(m2.pol, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Political") %>%
mutate("β > 0" = h0a_mo.pol$hypothesis$Evid.Ratio,
"β < 0" = h0b_mo.pol$hypothesis$Evid.Ratio)
m2.per.logit <- describe_posterior(m2.per, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Performance") %>%
mutate("β > 0" = h0a_mo.per$hypothesis$Evid.Ratio,
"β < 0" = h0b_mo.per$hypothesis$Evid.Ratio)
m2.neu.logit <- describe_posterior(m2.neu, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Neutral") %>%
mutate("β > 0" = h0a_mo.neu$hypothesis$Evid.Ratio,
"β < 0" = h0b_mo.neu$hypothesis$Evid.Ratio)
m2.logit <- bind_rows(m2.pol.logit, m2.per.logit, m2.neu.logit) %>%
select("Question Type", Parameter, Median,
CI_low, CI_high, "β > 0", "β < 0") %>%
rename("LL" = CI_low,
"UL" = CI_high) %>%
filter(Parameter == "bsp_moideo_motive_strength") %>%
mutate(Parameter = "Motive strength") %>%
mutate(across(where(is.numeric), ~ round(.x, 3)))
m2.logitSummary of Posterior Distribution
Question Type | Parameter | Median | LL | UL | β > 0 | β < 0
------------------------------------------------------------------------------
Political | Motive strength | 0.07 | 0.01 | 0.14 | 92.02 | 0.01
Performance | Motive strength | 0.06 | 0.02 | 0.12 | 614.38 | 2.00e-03
Neutral | Motive strength | -8.00e-03 | -0.05 | 0.04 | 0.54 | 1.85
m5 table
h1a_mo.pol <- as_tibble(m5.pol) %>%
hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct > 0",
alpha = 0.025,
seed = 42)
h1a_mo.per <- as_tibble(m5.per) %>%
hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct > 0",
alpha = 0.025,
seed = 42)
h1a_mo.neu <- as_tibble(m5.neu) %>%
hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct > 0",
alpha = 0.025,
seed = 42)
h1a_mo.pol$hypothesis$Evid.Ratio[1] 0.627
h1a_mo.per$hypothesis$Evid.Ratio[1] 37.8
h1a_mo.neu$hypothesis$Evid.Ratio[1] 0.684
h1b_mo.pol <- as_tibble(m5.pol) %>%
hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct < 0",
alpha = 0.025,
seed = 42)
h1b_mo.per <- as_tibble(m5.per) %>%
hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct < 0",
alpha = 0.025,
seed = 42)
h1b_mo.neu <- as_tibble(m5.neu) %>%
hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct < 0",
alpha = 0.025,
seed = 42)
h1b_mo.pol$hypothesis$Evid.Ratio[1] 1.59
h1b_mo.per$hypothesis$Evid.Ratio[1] 0.0264
h1b_mo.neu$hypothesis$Evid.Ratio[1] 1.46
m5.pol.logit <- describe_posterior(m5.pol, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Political") %>%
mutate("β > 0" = h1a_mo.pol$hypothesis$Evid.Ratio,
"β < 0" = h1b_mo.pol$hypothesis$Evid.Ratio)
m5.per.logit <- describe_posterior(m5.per, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Performance") %>%
mutate("β > 0" = h1a_mo.per$hypothesis$Evid.Ratio,
"β < 0" = h1b_mo.per$hypothesis$Evid.Ratio)
m5.neu.logit <- describe_posterior(m5.neu, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Neutral") %>%
mutate("β > 0" = h1a_mo.neu$hypothesis$Evid.Ratio,
"β < 0" = h1b_mo.neu$hypothesis$Evid.Ratio)
m5.logit <- bind_rows(m5.pol.logit, m5.per.logit, m5.neu.logit) %>%
select("Question Type", Parameter, Median,
CI_low, CI_high, "β > 0", "β < 0") %>%
rename("LL" = CI_low,
"UL" = CI_high) %>%
filter(Parameter == "bsp_moideo_motive_strength:scalecrt_correct") %>%
mutate(Parameter = "Motive strength x Cognitive Reflection") %>%
mutate(across(where(is.numeric), ~ round(.x, 3)))
m5.logitSummary of Posterior Distribution
Question Type | Parameter | Median | LL | UL | β > 0 | β < 0
-------------------------------------------------------------------------------------------------
Political | Motive strength x Cognitive Reflection | -3.00e-03 | -0.03 | 0.02 | 0.63 | 1.59
Performance | Motive strength x Cognitive Reflection | 0.05 | 0.00 | 0.12 | 37.84 | 0.03
Neutral | Motive strength x Cognitive Reflection | -5.00e-03 | -0.05 | 0.04 | 0.68 | 1.46
m6 table
h2a_mo.pol <- as_tibble(m6.pol) %>%
hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r > 0",
alpha = 0.025,
seed = 42)
h2a_mo.per <- as_tibble(m6.per) %>%
hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r > 0",
alpha = 0.025,
seed = 42)
h2a_mo.neu <- as_tibble(m6.neu) %>%
hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r > 0",
alpha = 0.025,
seed = 42)
h2a_mo.pol$hypothesis$Evid.Ratio[1] 0.761
h2a_mo.per$hypothesis$Evid.Ratio[1] 28.7
h2a_mo.neu$hypothesis$Evid.Ratio[1] 0.169
h2b_mo.pol <- as_tibble(m6.pol) %>%
hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r < 0",
alpha = 0.025,
seed = 42)
h2b_mo.per <- as_tibble(m6.per) %>%
hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r < 0",
alpha = 0.025,
seed = 42)
h2b_mo.neu <- as_tibble(m6.neu) %>%
hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r < 0",
alpha = 0.025,
seed = 42)
h2b_mo.pol$hypothesis$Evid.Ratio[1] 1.31
h2b_mo.per$hypothesis$Evid.Ratio[1] 0.0348
h2b_mo.neu$hypothesis$Evid.Ratio[1] 5.93
m6.pol.logit <- describe_posterior(m6.pol, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Political") %>%
mutate("β > 0" = h2a_mo.pol$hypothesis$Evid.Ratio,
"β < 0" = h2b_mo.pol$hypothesis$Evid.Ratio)
m6.per.logit <- describe_posterior(m6.per, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Performance") %>%
mutate("β > 0" = h2a_mo.per$hypothesis$Evid.Ratio,
"β < 0" = h2b_mo.per$hypothesis$Evid.Ratio)
m6.neu.logit <- describe_posterior(m6.neu, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Neutral") %>%
mutate("β > 0" = h2a_mo.neu$hypothesis$Evid.Ratio,
"β < 0" = h2a_mo.neu$hypothesis$Evid.Ratio)
m6.logit <- bind_rows(m6.pol.logit, m6.per.logit, m6.neu.logit) %>%
select("Question Type", Parameter, Median,
CI_low, CI_high, "β > 0", "β < 0") %>%
rename("LL" = CI_low,
"UL" = CI_high) %>%
filter(Parameter == "bsp_moideo_motive_strength:scalecommission_errors_r") %>%
mutate(Parameter = "Motive strength x Inhibitory Control") %>%
mutate(across(where(is.numeric), ~ round(.x, 3)))
m6.logitSummary of Posterior Distribution
Question Type | Parameter | Median | LL | UL | β > 0 | β < 0
---------------------------------------------------------------------------------------------------
Political | Motive strength x Inhibitory Control | -2.00e-03 | -0.03 | 0.02 | 0.76 | 1.31
Performance | Motive strength x Inhibitory Control | 0.05 | -4.00e-03 | 0.11 | 28.74 | 0.04
Neutral | Motive strength x Inhibitory Control | -0.03 | -0.09 | 0.02 | 0.17 | 0.17
Combined table
combined_mo_logit <- bind_rows(m2.logit, m5.logit, m6.logit) %>%
mutate(`Question Type` = factor(`Question Type`, levels = c("Political", "Performance", "Neutral"))) %>%
arrange(`Question Type`, Parameter)
combined_mo_logit_table <- combined_mo_logit %>%
select(-c("Question Type")) %>%
tt() %>%
group_tt(
i = list(
"Political Vignettes" = 1,
"Performance Vignettes" = 4,
"Neutral Vignettes" = 7
),
j = list(
"95% CI" = 3:4,
"Evidence Ratio" = 5:6))
combined_mo_logit_table %>% save_tt(here(table_dir, "combined_mo_logit_table.docx"), overwrite = TRUE)
combined_mo_logit_table| 95% CI | Evidence Ratio | ||||
|---|---|---|---|---|---|
| Parameter | Median | LL | UL | β > 0 | β < 0 |
| Motive strength | 0.068 | 0.012 | 0.135 | 92.023 | 0.011 |
| Motive strength x Cognitive Reflection | -0.003 | -0.031 | 0.019 | 0.627 | 1.595 |
| Motive strength x Inhibitory Control | -0.002 | -0.030 | 0.019 | 0.761 | 1.314 |
| Motive strength | 0.063 | 0.021 | 0.124 | 614.385 | 0.002 |
| Motive strength x Cognitive Reflection | 0.052 | 0.000 | 0.124 | 37.835 | 0.026 |
| Motive strength x Inhibitory Control | 0.046 | -0.004 | 0.109 | 28.740 | 0.035 |
| Motive strength | -0.008 | -0.053 | 0.039 | 0.541 | 1.849 |
| Motive strength x Cognitive Reflection | -0.005 | -0.047 | 0.042 | 0.684 | 1.463 |
| Motive strength x Inhibitory Control | -0.025 | -0.087 | 0.020 | 0.169 | 0.169 |
Supplementary Figure 2
Extract draws
m2.pol.draws <- m2.pol %>%
epred_draws(newdata = expand_grid(ideo_motive_strength = c("Anti-strong",
"Anti-moderate",
"Anti-weak",
"Pro-weak",
"Pro-moderate",
"Pro-strong"),
question_topic = levels(data_pol$question_topic)),
re_formula = ~(ideo_motive|question_topic))
m2.per.draws <- m2.per %>%
epred_draws(newdata = expand_grid(ideo_motive_strength = c("Anti-strong",
"Anti-moderate",
"Anti-weak",
"Pro-weak",
"Pro-moderate",
"Pro-strong"),
question_topic = levels(data_per$question_topic)),
re_formula = NA)
m2.neu.draws <- m2.neu %>%
epred_draws(newdata = expand_grid(ideo_motive_strength = c("Anti-strong",
"Anti-moderate",
"Anti-weak",
"Pro-weak",
"Pro-moderate",
"Pro-strong"),
question_topic = levels(data_neu$question_topic)),
re_formula = NA) m2.draws <- bind_rows(m2.pol.draws, m2.per.draws, m2.neu.draws) %>%
mutate(ideo_motive_strength = factor(ideo_motive_strength,
levels = c("Anti-strong",
"Anti-moderate",
"Anti-weak",
"Pro-weak",
"Pro-moderate",
"Pro-strong"),
ordered = TRUE),
question_topic = factor(question_topic,
levels = c("climate",
"immigration",
"gender",
"discrimination",
"adoption",
"punishment",
"gonogo_performance",
"fakenews_performance",
"teaculture",
"brain"),
labels = c("Anthropogenic climate change",
"Immigrant population",
"Gender stereotypes",
"Racial discrimination",
"Same-sex adoption",
"Criminal reconviction",
"Go / No-Go performance",
"Fake News performance",
"Tea with milk",
"Brain proportion")))Create figure
m2.draws %>%
mutate(perc = .epred * 100) %>%
ggplot(aes(x = perc, y = ideo_motive_strength, fill = ideo_motive_strength)) +
stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95),
point_interval = "median_qi") +
geom_vline(xintercept = 50, alpha = 0.8, linewidth = 0.8,
color = "black", linetype = "dashed") +
guides(fill = "none") +
scale_fill_manual(values = rev(beyonce_palette(41, n = 6,
type = "continuous"))) +
labs(title="Message Ratings by Motive Strength",
x = "Coefficients", y = NULL,
caption = "50% and 95% credible intervals shown in black") +
scale_x_continuous(labels = label_percent(scale = 1), limits = c(15, 85),
breaks = seq(20, 80, by = 10)) +
theme_ipsum_rc(base_size = 12,
plot_title_size = 14,
axis_title_size = 12,
axis_title_face = "bold",
axis_text_size = 12,
strip_text_size = 12,
strip_text_face = "bold"
) +
facet_wrap(~question_topic, ncol = 2)ggsave(here(fig_dir, "m2_perc_fig.png"), width = 8, height = 12, dpi = 300)